home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / oper_sys / weyl / weyl_lsp.lha / lisp-support.lisp < prev    next >
Encoding:
Text File  |  1991-10-04  |  15.2 KB  |  453 lines
  1. ;;; -*- Mode:Lisp; Package:User; Base:10; Lowercase:T; Syntax:Common-Lisp -*-
  2. ;;; ===========================================================================
  3. ;;;                  Lisp Support
  4. ;;; ===========================================================================
  5. ;;; (c) Copyright 1989, 1991 Cornell University
  6.  
  7. ;;; $Id: lisp-support.lisp,v 2.12 1991/10/04 22:43:27 rz Exp $
  8.  
  9. (in-package "USER")
  10.  
  11. #-Genera
  12. (defmacro weyli::lambda (args &body body)
  13.   `(function (lambda ,args ,@body)))
  14.  
  15. ;; The following is done instead of importing defgeneric and
  16. ;; defmethod, to avoid muddying the user package.   
  17. #+PCL
  18. (progn
  19.   (defmacro clos-defgeneric (&rest args) `(pcl:defgeneric . ,args))
  20.   (defmacro clos-defmethod (&rest args) `(pcl:defmethod . ,args)))
  21.  
  22. #+(and CLOS (not Allegro-v4.0))
  23. (progn
  24.   (defmacro clos-defgeneric (&rest args) `(clos:defgeneric . ,args))
  25.   (defmacro clos-defmethod (&rest args) `(clos:defmethod . ,args)))
  26.  
  27. ;; Extend defmethod slightly
  28.  
  29. #+PCL
  30. (defmacro weyli::defmethod (&rest args &environment env)
  31.   (declare (pcl::arglist name
  32.             {method-qualifier}*
  33.             specialized-lambda-list
  34.             &body body))
  35.   (labels ((duplicate-arglist (arglist)
  36.          (cond ((null arglist) (list nil))
  37.            ((or (atom (first arglist))
  38.             (null (rest (first arglist)))
  39.             (atom (second (first arglist)))
  40.             (not (eql 'or (first (second (first arglist))))))
  41.             (mapcar (lambda (q) (cons (first arglist) q))
  42.                 (duplicate-arglist (rest arglist))))
  43.            (t (loop for type in (rest (second (first arglist)))
  44.                 with rest = (duplicate-arglist (rest arglist))
  45.                 nconc (mapcar (lambda (q)
  46.                         (cons (list (first (first arglist)) type)
  47.                           q))
  48.                       rest))))))
  49.     (multiple-value-bind (name qualifiers lambda-list body)
  50.     (pcl::parse-defmethod args)
  51.       (let ((proto-method (pcl::method-prototype-for-gf name)))
  52.     `(progn
  53.        ,@(loop for ll in (duplicate-arglist lambda-list)
  54.            collect
  55.              (pcl::expand-defmethod proto-method name qualifiers ll body env)))))))
  56.  
  57. #+CLOS
  58. (defmacro weyli::defmethod (&rest args)
  59.   (declare (arglist name
  60.             {method-qualifier}*
  61.             specialized-lambda-list
  62.             &body body))
  63.   (labels ((duplicate-arglist (arglist)
  64.          (cond ((null arglist) (list nil))
  65.            ((or (atom (first arglist))
  66.             (null (rest (first arglist)))
  67.             (atom (second (first arglist)))
  68.             (not (eql 'or (first (second (first arglist))))))
  69.             (mapcar (lambda (q) (cons (first arglist) q))
  70.                 (duplicate-arglist (rest arglist))))
  71.            (t (loop for type in (rest (second (first arglist)))
  72.                 with rest = (duplicate-arglist (rest arglist))
  73.                 nconc (mapcar (lambda (q)
  74.                         (cons (list (first (first arglist)) type)
  75.                           q))
  76.                       rest))))))
  77.     #-LispWorks
  78.     (multiple-value-bind (name qualifiers lambda-list body)
  79.           #+Lucid (clos::parse-defmethod args)
  80.       #+Genera (clos-parse-defmethod args)
  81.       `(progn
  82.     ,@(loop for ll in (duplicate-arglist lambda-list)
  83.         collect
  84.          `(clos::defmethod ,name ,@qualifiers ,ll ,@body))))
  85.     #+LispWorks
  86.     (let ((name (first args)))
  87.       (multiple-value-bind (qualifiers lambda-list body)
  88.             (clos::parse-defmethod nil name (rest args))
  89.         `(progn
  90.       ,@(loop for ll in (duplicate-arglist lambda-list)
  91.           collect
  92.              `(clos:defmethod ,name ,@qualifiers ,ll ,@body)))))))
  93.  
  94. #+(and Genera CLOS)
  95. (defun clos-parse-defmethod (form)
  96.   (let ((name (pop form))
  97.     qualifiers)
  98.     (loop while (and (atom (first form))
  99.              (not (null (first form))))
  100.       do (push (pop form) qualifiers))
  101.     (values name (reverse qualifiers) (first form) (rest form))))
  102.  
  103. (defmacro weyli::%funcall (function &rest args)
  104.   `(lisp:funcall ,function ,@args))
  105.  
  106. (clos-defmethod weyli::funcall (function &rest args)
  107.   (lisp:apply function args))
  108.  
  109. (defmacro weyli::%apply (function &rest args)
  110.   `(lisp:apply ,function ,@args))
  111.  
  112. (clos-defmethod weyli::apply (function &rest args)
  113.   (labels ((accum (args)
  114.          (cond ((null (rest args))
  115.             args)
  116.            (t (cons (first args) (accum (rest args)))))))
  117.     (cond ((null args)
  118.        (error "The function APPLY was called with too few arguments"))
  119.       (t (lisp:apply function (accum args))))))
  120.  
  121. (clos-defgeneric weyli::delete (item set &key &allow-other-keys)
  122.   )
  123.  
  124. (clos-defmethod weyli::delete (item (sequence sequence) &rest args)
  125.   (apply #'lisp:delete item sequence args))
  126.  
  127. (clos-defgeneric weyli::member (item list &key &allow-other-keys)
  128.   )
  129.  
  130. (clos-defmethod weyli::member (item (list list) &rest args)
  131.   (apply #'lisp:member item list args))
  132.  
  133. (clos-defgeneric weyli::replace (item list &key &allow-other-keys)
  134.   )
  135.  
  136. (clos-defmethod weyli::replace ((item sequence) (list sequence) &rest args)
  137.   (apply #'lisp:replace item list args))
  138.  
  139. (clos-defgeneric weyli::substitute
  140.     (newitem olditem sequence &key &allow-other-keys)
  141.   )
  142.  
  143. (clos-defmethod weyli::substitute (newitem olditem (seq sequence) &rest args)
  144.   (apply #'lisp:substitute newitem olditem seq args))
  145.  
  146. (clos-defgeneric weyli::map (result-type function sequence &rest sequences)
  147.   )
  148.  
  149. (clos-defmethod weyli::map (result-type function sequence &rest sequences)
  150.   (apply #'lisp:map result-type function sequence sequences))
  151.  
  152. (clos-defgeneric weyli::reduce (function sequence &rest options)
  153.   )
  154.  
  155. (clos-defmethod weyli::reduce (function (sequence sequence) &rest options)
  156.   (apply #'lisp:reduce function sequence options))
  157.  
  158.  
  159. #+Genera
  160. (eval-when (compile load eval)
  161.   ;; Link the value cells of algebra:* and zl:*, etc.
  162.   (unless (eq (locf (symbol-value 'weyli::*))
  163.           (locf (symbol-value 'zl:*)))
  164.     (setq weyli::* zl:*)
  165.     (si:link-symbol-value-cells 'weyli::* 'zl:*))
  166.   (unless (eq (locf (symbol-value 'weyli::+))
  167.           (locf (symbol-value 'zl:+)))
  168.     (setq weyli::+ zl:+)
  169.     (si:link-symbol-value-cells 'weyli::+ 'zl:+))
  170.   )
  171.  
  172. #+Lucid
  173. (setf (symbol-function 'lucid-old-top-level-eval) #'lucid::top-level-eval)
  174.  
  175. #+Lucid
  176. (defun  lucid::top-level-eval (&rest arguments)
  177.   (declare (special weyli::* weyli::+ lisp:* lisp:+))
  178.   (multiple-value-prog1 (apply #'lucid-old-top-level-eval arguments)
  179.     (setq weyli::* lisp:*)
  180.     (setq weyli::+ lisp:+)))
  181.  
  182. (defmacro weyli::defsubst (function lambda-list &body body)
  183.   `(#+Genera scl:defsubst
  184.     #+Lucid  lcl:defsubst
  185.     #-(or Genera Lucid) defun
  186.     ,function ,lambda-list ,@body))
  187.  
  188. ;;Infinities...
  189.  
  190. (defvar weyli::*positive-infinity*
  191.     #+Genera si:infinite-positive-double-float
  192.     #+Lucid system:float-positive-infinity)
  193.  
  194. (defvar weyli::*negative-infinity*
  195.     #+Genera si:infinite-negative-double-float
  196.     #+Lucid system:float-negative-infinity)
  197.  
  198. (defmacro weyli::copy-array-contents (from-array to-array)
  199.   #+Genera
  200.   `(scl:copy-array-contents ,from-array ,to-array)
  201.   #-Genera
  202.   `(copy-array-contents* ,from-array ,to-array))
  203.  
  204. #+Lucid
  205. (defun copy-array-contents* (from-array to-array)
  206.   (let ((from-dims (array-dimensions from-array))
  207.     (to-dims (array-dimensions to-array)))
  208.     (unless (eql (length from-dims) (length to-dims))
  209.       (error "Incompatable array dimensions: ~A -> ~A"
  210.          from-array to-array))
  211.     (labels ((worker (from-dims to-dims indices)
  212.            (cond ((null from-dims)
  213.               (apply #'lucid-runtime-support:set-aref
  214.                  (apply #'aref from-array indices)
  215.                  to-array indices))
  216.              (t (loop for i below (min (first from-dims)
  217.                            (first to-dims))
  218.                   do (worker (rest from-dims) (rest to-dims)
  219.                      (cons i indices)))))))
  220.       (worker (reverse from-dims) (reverse to-dims) nil))))
  221.  
  222.  
  223. #+LispWorks
  224. (defun copy-array-contents* (from-array to-array)
  225.   (let ((from-dims (array-dimensions from-array))
  226.     (to-dims (array-dimensions to-array)))
  227.     (unless (eql (length from-dims) (length to-dims))
  228.       (error "Incompatable array dimensions: ~A -> ~A"
  229.          from-array to-array))
  230.     (labels ((worker (from-dims to-dims indices)
  231.            (cond ((null from-dims)
  232.               (apply #'system::set-aref
  233.                  (apply #'aref from-array indices)
  234.                  to-array indices))
  235.              (t (loop for i below (min (first from-dims)
  236.                            (first to-dims))
  237.                   do (worker (rest from-dims) (rest to-dims)
  238.                      (cons i indices)))))))
  239.       (worker (reverse from-dims) (reverse to-dims) nil))))
  240.  
  241. (defun weyli::circular-list (&rest arguments)
  242.   #+Genera (apply #'scl:circular-list arguments)
  243.   #-Genera (nconc arguments arguments))
  244.  
  245. (weyli::defsubst structure-of (x)
  246.   (lisp:type-of x))
  247.  
  248. ;; The following macros deal with certain functions that should take an
  249. ;; arbitrary number of arguments.
  250.  
  251. (defun associate-operation (operation values)
  252.   (labels ((iterate (values result)
  253.          (cond ((null values)
  254.             result)
  255.            (t (iterate (rest values)
  256.                    `(,operation ,result ,(first values)))))))
  257.     (iterate (rest values) (first values))))
  258.  
  259. (defmacro weyli::max (&rest values)
  260.   (cond ((null values)
  261.      (error "Illegal number of arguments to +"))
  262.     ((null (rest values))
  263.      (first values))
  264.     (t (associate-operation 'weyli::max-pair values))))
  265.  
  266. (defmacro weyli::min (&rest values)
  267.   (cond ((null values)
  268.      (error "Illegal number of arguments to +"))
  269.     ((null (rest values))
  270.      (first values))
  271.     (t (associate-operation 'weyli::min-pair values))))
  272.  
  273. (defmacro weyli::+ (&rest values)
  274.   (cond ((null values)
  275.      (error "Illegal number of arguments to +"))
  276.     ((null (rest values))
  277.      (first values))
  278.     (t (associate-operation 'weyli::plus values))))
  279.  
  280. (defmacro weyli::- (&rest values)
  281.   (cond ((null values)
  282.      (error "Illegal number of arguments to +"))
  283.     ((null (rest values))
  284.      `(weyli::minus ,(first values)))
  285.     (t (associate-operation 'weyli::difference values))))
  286.  
  287. (defmacro weyli::* (&rest values)
  288.   (cond ((null values)
  289.      (error "Illegal number of arguments to +"))
  290.     ((null (rest values))
  291.      (first values))
  292.     (t (associate-operation 'weyli::times values))))
  293.  
  294. (defmacro weyli::/ (&rest values)
  295.   (cond ((null values)
  296.      (error "Illegal number of arguments to +"))
  297.     ((null (rest values))
  298.      `(weyli::recip ,(first values)))
  299.     (t (associate-operation 'weyli::quotient values))))
  300.  
  301. #+Genera
  302. (cp:define-command (com-copy-system-to-unix :command-table "User"
  303.                         :provide-output-destination-keyword nil)
  304.     ((sct::*system* 'sct:system)
  305.      &key 
  306.      (to-directory '((fs:pathname) :dont-merge-default t)
  307.            :default (sct:system-default-pathname sct::*system*)
  308.            :confirm t
  309.            :prompt "to" 
  310.            :documentation "Destination directory ")
  311.      (binary-type 'string :default "SBIN"
  312.           :documentation "Binary extension for Unix")
  313.      (version '(or number (member :latest :newest))
  314.           :default :latest
  315.           :prompt "Version "
  316.           :documentation "Version of system to copy")
  317.      (require-pcl 'boolean
  318.           :default t
  319.           :documentation "True if this system requires that PCL be loaded"))
  320.    (let ((sct::*version* version)
  321.      (sct::*branch* nil)
  322.      (system-plan)
  323.      (system-file))
  324.      (setq system-file
  325.        (send 
  326.          (second
  327.            (assoc 'scl:defsystem (get (sct:system-name sct:*system*) :source-file-name)))
  328.          :new-type :lisp))
  329.  
  330.      ;; The idea is reasonable, unfortunately TFTP can't set the creation-date of a file.
  331.      (flet ((update-file (file)
  332.           (let ((to-file (fs:merge-pathnames to-directory file)))
  333.         (unless (eql (getf (rest (second (fs:directory-list file))) :creation-date)
  334.                  (getf (rest (second (fs:directory-list to-file))) :creation-date))
  335.           (copy-file file to-file :report-stream *standard-output*)))))
  336.        (update-file system-file)
  337.        (loop for file in (sct:get-all-system-input-files sct:*system* :version version)
  338.          do (update-file file)))
  339.      (setq system-plan (sct:make-plan-for-system :recompile t))
  340.      (with-open-file (stream (fs:merge-pathnames
  341.                    (string-downcase
  342.                  (format nil "load-~A.lisp"
  343.                      (sct:system-name sct:*system*)))
  344.                    to-directory)
  345.                  :direction :output)
  346.        (princ ";; This file was automatically generated by a program." stream)
  347.        (fresh-line stream)
  348.        (princ ";;   Changing it will do no good and the changes will be lost." stream)
  349.        (fresh-line stream)
  350.        (print '(in-package 'user) stream)
  351.        (fresh-line stream)
  352.        (when require-pcl 
  353.      (print
  354.        `(unless (find-package 'pcl)
  355.           (load "/usr/fsys/nori/a/pcl/defsys")
  356.           (funcall (intern 'load-pcl 'pcl)))
  357.        stream)
  358.      (fresh-line stream))
  359.        (flet ((compile-file-form (file)
  360.         `(compile-file ,(send (fs:merge-pathnames to-directory file)
  361.                       :string-for-host)))
  362.           (load-file-form (file &optional (binary-p t))
  363.         `(load ,(send (fs:merge-pathnames
  364.                 (if binary-p
  365.                     (send to-directory :new-type binary-type)
  366.                     (send to-directory :new-type :lisp))
  367.                 file)
  368.                   :string-for-host))))
  369.      (print
  370.        `(defun ,(intern (format nil "COMPILE-~A" (sct:system-name sct:*system*))) ()
  371.           ,(load-file-form system-file nil)
  372.           ,@(loop for plan in system-plan
  373.               when (eql (sct:plan-default-input-type plan) :lisp)
  374.             nconc
  375.               (nconc (loop for file in (sct:plan-inputs plan)
  376.                        collect (compile-file-form file))
  377.                  (loop for file in (sct:plan-inputs plan)
  378.                        collect (load-file-form file)))))
  379.        stream)
  380.      (fresh-line stream)
  381.      (print
  382.        `(defun ,(intern (format nil "LOAD-~A" (sct:system-name sct:*system*))) ()
  383.           ,(load-file-form system-file nil)
  384.           ,@(loop for plan in system-plan
  385.               when (eql (sct:plan-default-input-type plan) :lisp)
  386.             nconc
  387.               (loop for file in (sct:plan-inputs plan)
  388.                 collect (load-file-form file))))
  389.        stream)))))
  390.  
  391. #+PCL
  392. (defvar pcl::*compile-class-hash* (make-hash-table :test #'eq))
  393.  
  394. #+PCL
  395. (defun pcl::COMPILE-CLASS-METHODS-1 (classes)
  396.   (clrhash pcl::*compile-class-hash*)
  397.   (dolist (class-spec classes)
  398.     (let ((class (cond ((symbolp class-spec) (pcl::find-class class-spec nil))
  399.                ((pcl::classp class-spec) class-spec))))
  400.       (cond (class
  401.          (dolist (gf (pcl::class-direct-generic-functions class))
  402.            (unless (gethash gf pcl::*compile-class-hash*)
  403.          (setf (gethash gf pcl::*compile-class-hash*) T)
  404.          (pcl::notice-methods-change-1 gf))))
  405.         (t (warn "~A is neither a class nor the name of a class" class-spec))))))
  406.  
  407. #+PCL
  408. (defmacro weyli::compile-class-methods (&rest classes)
  409.   `(pcl::compile-class-methods-1 ',classes))
  410.  
  411. #-PCL
  412. (defmacro compile-class-methods (&rest classes)
  413.   (declare (ignore classes))
  414.   "Ignored")
  415.  
  416. #+PCL
  417. (defun weyli::class-uncompiled-methods (class-spec &optional (function #'print))
  418.   (let ((class (cond ((symbolp class-spec) (pcl::find-class class-spec nil))
  419.              ((pcl::classp class-spec) class-spec))))
  420.     (cond (class
  421.        (dolist (gf (pcl::class-direct-generic-functions class))
  422.          (dolist (method (pcl::generic-function-methods gf))
  423.            (unless (or (compiled-function-p (pcl::method-function method))
  424.                #+Genera
  425.                (typep (pcl::method-function method) 'sys:lexical-closure))
  426.          (funcall function method)))))
  427.       (t (warn "~A is neither a class nor the name of a class" class-spec)))))
  428.  
  429. #+PCL
  430. (defun weyli::all-weyl-classes (&optional (function #'print))
  431.   (let (list)
  432.     (labels ((find-sub-classes (class)
  433.            (loop for class in (pcl::class-direct-subclasses class)
  434.              do (unless (member class list)
  435.               (push class list)
  436.               (funcall function class)
  437.               (find-sub-classes class)))))
  438.       (find-sub-classes (pcl::find-class 'weyli::domain))
  439.       (find-sub-classes (pcl::find-class 'weyli::domain-element))
  440.       (find-sub-classes (pcl::find-class 'weyli::morphism)))))
  441.  
  442. #+PCL
  443. (defun weyli::all-uncompiled-weyl-methods (&optional (function #'print))
  444.   (let (list generic)
  445.     (weyli::all-weyl-classes
  446.       (lambda (class)
  447.     (weyli::class-uncompiled-methods class
  448.        (lambda (method)
  449.          (setq generic (pcl::method-generic-function method))
  450.          (unless (member generic list)
  451.          (push generic list)
  452.          (funcall function generic))))))))
  453.